home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / p063b9s.zip / UNIT / RBROWSER.PAS < prev    next >
Pascal/Delphi Source File  |  1997-03-02  |  13KB  |  380 lines
  1. UNIT RBrowser;
  2. {╔══════════════════════════════════════════════════════════════════════════╗}
  3. {║ File record browser                           Last changed: 02.03.97  SA ║}
  4. {║                                                                          ║}
  5. {║                         (C) Copyright 1989-97 by                         ║}
  6. {║       Dan Wulff, Jens Sandalgaard, Steen Christensen & S¢ren Ager        ║}
  7. {║                                                                          ║}
  8. {║ This source may not be given to anybody, without the written permission  ║}
  9. {║ from The Portal Team.                                                    ║}
  10. {╚══════════════════════════════════════════════════════════════════════════╝}
  11. {$I POPDEFS.INC}
  12.  
  13. INTERFACE
  14.  
  15. USES Use32, PoPTypes, NetFile;
  16.  
  17. CONST
  18.   Allowed : Byte = $ff;
  19.  
  20. TYPE
  21.   GetStrFuncType = FUNCTION(VAR Buffer; VAR f: TNetFile): String;
  22.   EditProcType   = PROCEDURE(VAR Buffer; VAR Changed: Boolean; RecNum,MaxRec: LongInt);
  23.   InitBufType    = PROCEDURE(VAR Buffer);
  24.   IsGreaterFunc  = FUNCTION(VAR B1,B2): Boolean;
  25.   GetRecFunc     = PROCEDURE(VAR f: TNetFile; VAR Buffer; RecNum: LongInt; K,W: Boolean);
  26.   PutRecFunc     = PROCEDURE(VAR f: TNetFile; VAR Buffer; RecNum: LongInt);
  27.  
  28. VAR
  29.   GetARec : GetRecFunc;
  30.   PutARec : PutRecFunc;
  31.  
  32. PROCEDURE DefGetRec(VAR f: TNetFile; VAR Buffer; RecNum: LongInt; K,W: Boolean);
  33. PROCEDURE DefPutRec(VAR f: TNetFile; VAR Buffer; RecNum: LongInt);
  34.  
  35. PROCEDURE BrowseRecords(VAR f: TNetFile;
  36.                         VAR Buffer;
  37.                         VAR ExitCode: Word;
  38.                         CONST Head,
  39.                               RowString: S80;
  40.                         GSP: GetStrFuncType;
  41.                         EP : EditProcType;
  42.                         IB : InitBufType;
  43.                         IG : IsGreaterFunc);
  44.  
  45. IMPLEMENTATION
  46.  
  47. USES Dos, OpCrt, OpWindow, OpString, OpKey, OpRoot,
  48.      OproUtil, Keyboard, Input, Globals, Util, Display;
  49.  
  50.   PROCEDURE DefGetRec(VAR f: TNetFile; VAR Buffer; RecNum: LongInt; K,W: Boolean);
  51.   BEGIN
  52.     f.GetRec(Buffer, RecNum, K, W);
  53.   END;
  54.  
  55.   PROCEDURE DefPutRec(VAR f: TNetFile; VAR Buffer; RecNum: LongInt);
  56.   BEGIN
  57.     f.PutRec(Buffer, RecNum);
  58.   END;
  59.  
  60.  
  61.   PROCEDURE BrowseRecords;
  62.   LABEL
  63.     EditBuffer;
  64.   VAR
  65.     HelpWin, MainWin,
  66.     ScrollWin, Win   : WindowPtr;
  67.     y, ymax : Byte;
  68.     OldRecNum,RecNum : LongInt;
  69.     Found,Changed, TheEnd  : Boolean;
  70.     FindStr, OutputName    : PathStr;
  71.     PrintFile : PBufTextFile;
  72.     WaitWin   : PWait;
  73.  
  74.     PROCEDURE WriteLine(RecNum: LongInt; y: Byte; Rvs: Boolean);
  75.     VAR
  76.       s    : String;
  77.       Color: Byte;
  78.     BEGIN
  79.       IF f.FileSize>0 THEN
  80.       BEGIN
  81.         GetARec(f,Buffer,RecNum,NoKeep,NoWait);
  82.         IF f.IoResult=107 THEN
  83.           s:='* * * * * * * * * * *  R E C O R D   I S   L O C K E D  * * * * * * * * * * *'
  84.         ELSE
  85.           s:=GSP(Buffer, f);
  86.       END ELSE
  87.         s:='* * * * * * * * * *  N O   R E C O R D S   I N   F I L E  * * * * * * * * * *' ;
  88.       IF Rvs THEN Color:=Cfg.Color[3].BlockColor ELSE Color:=Cfg.Color[3].TextColor;
  89.       ScrollWin^.wFastWrite(' '+Pad(s,77),y,1,Color);
  90.     END;
  91.  
  92.     PROCEDURE WritePage(StartRecNum: LongInt);
  93.     VAR
  94.       y : Byte;
  95.     BEGIN
  96.       y:=1;
  97.       WHILE (StartRecNum<f.FileSize) And (y<=ymax) DO
  98.       BEGIN
  99.         WriteLine(StartRecNum,y,False) ;
  100.         Inc(y); Inc(StartRecNum);
  101.       END;
  102.       IF y<=ymax THEN
  103.         FOR y:=y TO ymax DO
  104.           ScrollWin^.wFastText(CharStr(' ',78),y,1);
  105.     END;
  106.  
  107.     PROCEDURE SortRecords;
  108.     CONST
  109.       Faktor = 1.3;
  110.     VAR
  111.       i, Gab    : LONGINT;
  112.       b1,b2     : Pointer;
  113.       Sorteret  : BOOLEAN;
  114.     BEGIN
  115.       New(WaitWin, Init(ScreenHeight DIV 2, 3, 'Sorting records'));
  116.       GetMem(b1,f.RecSize);
  117.       GetMem(b2,f.RecSize);
  118.  
  119.       Gab:=f.FileSize ; Sorteret:=False;
  120.       while (Gab>1) or not Sorteret do
  121.       begin
  122.         Gab:=Trunc(Gab/Faktor);
  123.         if Gab<1 then Gab:=1;
  124.         Sorteret:=True;
  125.         I:=0;
  126.         while I<f.FileSize-Gab do
  127.         begin
  128.           WaitWin^.Animate;
  129.           GetARec(f,b1^,i,NetFile.Keep,Wait);
  130.           GetARec(f,b2^,i+Gab,NetFile.Keep,Wait);
  131.           IF IG(b1^, b2^) THEN
  132.           BEGIN
  133.             PutARec(f,b2^,i); PutARec(f,b1^,i+Gab);
  134.             Sorteret:=False;
  135.           END ELSE
  136.           BEGIN
  137.             f.UnLock(i);
  138.             f.UnLock(i+Gab);
  139.           END;
  140.           Inc(i);
  141.         end;
  142.       end;
  143.       FreeMem(b2,f.RecSize);
  144.       FreeMem(b1,f.RecSize);
  145.       Dispose(WaitWin, Done);
  146.     END;
  147.  
  148.     PROCEDURE MakeHelpWin;
  149.     VAR
  150.       s : s80;
  151.     BEGIN
  152.       MyWin(HelpWin,1,ScreenHeight-1,80,ScreenHeight,3,'',False);
  153.       WITH HelpWin^, Cfg.Color[3] DO
  154.       BEGIN
  155.         s:='F1=Help        F2=';
  156.         IF (Allowed AND 1)<>0 THEN s:=s+'Delete      ' ELSE s:=s+CharStr(' ',12);
  157.         s:=s+'F3=';
  158.         IF (Allowed AND 2)<>0 THEN s:=s+'Print       ' ELSE s:=s+CharStr(' ',12);
  159.         s:=s+'F4=';
  160.         IF (Allowed AND 4)<>0 THEN s:=s+'Create      ' ELSE s:=s+CharStr(' ',12);
  161.         s:=s+'F5=';
  162.         IF (Allowed AND 8)<>0 THEN s:=s+'Find' ;
  163.         wFastText(s,1,2);
  164.  
  165.         s:='F6=';
  166.         IF (Allowed AND 16)<>0 THEN s:=s+'Copy entry  ' ELSE s:=s+CharStr(' ',12);
  167.         s:=s+'F7=';
  168.         IF (Allowed AND 32)<>0 THEN s:=s+'Sort        ' ELSE s:=s+CharStr(' ',12);
  169.         s:=s+'F8=            F9=            F0=';
  170.         wFastText(s,2,2);
  171.       END;
  172.     END;
  173.  
  174.     PROCEDURE EditTheBuffer;
  175.     BEGIN
  176.       Topic:=0;
  177.       EP(Buffer, Changed, RecNum, f.FileSize);
  178.       Topic:=63;
  179.     END;
  180.  
  181.   BEGIN
  182.     MakeHelpWin;
  183.     MyWin(MainWin,1,2,80,ScreenHeight-2,3,Head,False);
  184.     MainWin^.wFastText(' '+Pad(RowString,77),1,1);
  185.     MyWin(ScrollWin,2,4,79,ScreenHeight-3,3,'',False);
  186.     ymax:=ScreenHeight-6;
  187.     WritePage(0);
  188.     y:=1; RecNum:=0; TheEnd:=False; FindStr:=''; Topic:=63; OutputName:='';
  189.     REPEAT
  190.       WriteLine(RecNum,y,True);
  191.       REPEAT UNTIL PoPKeyPressed ;
  192.       WriteLine(RecNum,y,False);
  193.       CASE PoPReadKeyWord OF
  194.         Esc     : TheEnd:=True;
  195.         Enter   : BEGIN
  196.                     IF f.FileSize=0 THEN
  197.                       IB(Buffer)
  198.                     ELSE
  199.                       GetARec(f, Buffer, RecNum, NetFile.Keep, NoWait);
  200.                     IF f.IOResult=0 THEN
  201.                     BEGIN
  202.                       MyWin(Win, 1, ScreenHeight-1, 80, ScreenHeight, 2, '', False);
  203.                       WITH Win^, Cfg.Color[2] DO
  204.                       BEGIN
  205.                         wFastText('F1=Help',1,2);
  206.                       END;
  207.  
  208.                       EditTheBuffer;
  209.  
  210.                       KillWindow(Win);
  211.  
  212.                       IF Changed THEN
  213.                         PutARec(f,Buffer,RecNum)
  214.                       ELSE
  215.                         IF f.FileSize>0 THEN f.UnLock(RecNum);
  216.                     END;
  217.                     MainWin^.Select;
  218.                     ScrollWin^.Select;
  219.                   END;
  220.         Down    : IF RecNum<f.FileSize-1 THEN
  221.                   BEGIN
  222.                     Inc(RecNum); Inc(y);
  223.                     IF y>ymax THEN
  224.                     BEGIN
  225.                       y:=ymax;
  226.                       ScrollWin^.ScrollVert(1);
  227.                     END;
  228.                   END;
  229.         Up      : IF RecNum>0 THEN
  230.                   BEGIN
  231.                     Dec(RecNum); Dec(y);
  232.                     IF y<1 THEN
  233.                     BEGIN
  234.                       y:=1;
  235.                       ScrollWin^.ScrollVert(-1);
  236.                     END;
  237.                   END;
  238.         PgDn    : BEGIN
  239.                     IF RecNum+ymax>=f.FileSize THEN
  240.                     BEGIN
  241.                       IF f.FileSize>0 THEN RecNum:=f.FileSize-1 ELSE RecNum:=0;
  242.                       IF RecNum<ymax THEN y:=RecNum+1 ELSE y:=ymax;
  243.                     END ELSE
  244.                     BEGIN
  245.                       Inc(RecNum,ymax);
  246.                     END;
  247.                     WritePage(RecNum-y+1);
  248.                   END;
  249.         PgUp    : BEGIN
  250.                     IF RecNum<ymax+y THEN
  251.                     BEGIN
  252.                       RecNum:=0;
  253.                       y:=1;
  254.                     END ELSE
  255.                     BEGIN
  256.                       Dec(RecNum,ymax);
  257.                     END;
  258.                     WritePage(RecNum-y+1);
  259.                   END;
  260.         Home    : BEGIN
  261.                     RecNum:=0; y:=1;
  262.                     WritePage(RecNum);
  263.                   END;
  264.         EndKey  : BEGIN
  265.                     IF f.FileSize>0 then RecNum:=f.FileSize-1 else RecNum:=0;
  266.                     IF RecNum<ymax THEN y:=RecNum+1 ELSE y:=ymax;
  267.                     WritePage(RecNum-y+1);
  268.                   END;
  269.         Del,
  270.         F2      : IF (Allowed AND 1)<>0 THEN
  271.                   BEGIN
  272.                     IF (f.FileSize>0) And (Confirm('Delete current record?','N',10)) THEN
  273.                     BEGIN
  274.                       New(WaitWin, Init(ScreenHeight DIV 2, 3, 'Reordering records'));
  275.                       f.Seek(RecNum) ;
  276.                       WHILE f.FilePos<f.FileSize-1 DO
  277.                       BEGIN
  278.                         WaitWin^.Animate;
  279.                         GetARec(f, Buffer, f.FilePos+1, NoKeep, Wait);
  280.                         PutARec(f, Buffer, f.FilePos-2);
  281.                       END;
  282.                       f.Seek(f.FileSize-1);
  283.                       f.Truncate;
  284.                       Dispose(WaitWin, Done);
  285.                       IF RecNum>=f.FileSize THEN
  286.                       BEGIN
  287.                         Dec(RecNum);
  288.                         IF y>1 THEN Dec(y);
  289.                       END;
  290.                       WritePage(RecNum-y+1);
  291.                     END;
  292.                   END;
  293.         F3      : IF (Allowed AND 2)<>0 THEN
  294.                   BEGIN
  295.                     IF (f.FileSize>0) And
  296.                        InputString(10,12,80,44,3,'Print','Print to : ',OutputName) And (OutputName<>'') THEN
  297.                     BEGIN
  298.                       New(PrintFile, Init(OutputName,SCreate,2048));
  299.                       IF PrintFile<>NIL THEN
  300.                       BEGIN
  301.                         FOR OldRecNum:=0 TO f.FileSize-1 DO
  302.                         BEGIN
  303.                           GetARec(f,Buffer,OldRecNum,NoKeep,Wait);
  304.                           PrintFile^.WriteLn(GSP(Buffer, f));
  305.                         END;
  306.                         Dispose(PrintFile, Done);
  307.                       END;
  308.                     END;
  309.                   END;
  310.         Ins,
  311.         F4      : IF (Allowed AND 4)<>0 THEN
  312.                   BEGIN
  313.                     IB(Buffer);
  314. EditBuffer:
  315.                     OldRecNum:=RecNum;
  316.                     RecNum:=f.FileSize;
  317.                     EditTheBuffer;
  318.                     IF Changed THEN
  319.                     BEGIN
  320.                       PutARec(f,Buffer,RecNum);
  321.                       IF RecNum<ymax THEN y:=RecNum+1 ELSE y:=ymax;
  322.                     END ELSE
  323.                       RecNum:=OldRecNum;
  324.                     MainWin^.Select;
  325.                     ScrollWin^.Select;
  326.                     WritePage(RecNum-y+1);
  327.                   END;
  328.         F5      : IF (Allowed AND 8)<>0 THEN
  329.                   BEGIN
  330.                     IF (RecNum=0) Or (RecNum=f.FileSize-1) Or (FindStr='') THEN
  331.                     BEGIN
  332.                       Found:=InputString(10,12,80,44,3,'Find','String to find : ',FindStr);
  333.                     END ELSE
  334.                       Found:=True;
  335.                     IF Found THEN
  336.                     BEGIN
  337.                       OldRecNum:=RecNum;
  338.                       Found:=False;
  339.                       IF RecNum=f.FileSize-1 THEN RecNum:=0 ELSE Inc(RecNum);
  340.                       WHILE (RecNum<f.FileSize) And Not (Found) DO
  341.                       BEGIN
  342.                         GetARec(f,Buffer,RecNum,NoKeep,NoWait);
  343.                         Found:=Pos(StUpCase(FindStr),StUpCase(GSP(Buffer, f)))<>0;
  344.                         IF NOT Found THEN Inc(RecNum);
  345.                       END;
  346.                       IF Found THEN
  347.                       BEGIN
  348.                         y:=1;
  349.                         WritePage(RecNum-y+1);
  350.                       END ELSE
  351.                       BEGIN
  352.                         RecNum:=OldRecNum;
  353.                         FindStr:='';
  354.                       END;
  355.                     END;
  356.                   END;
  357.         F6      : IF ((Allowed AND 16)<>0) AND (f.FileSize>0) THEN
  358.                   BEGIN
  359.                     GetARec(f,Buffer,RecNum,NoKeep,Wait);
  360.                     GOTO EditBuffer;
  361.                   END;
  362.         F7      : IF (Allowed AND 32)<>0 THEN
  363.                   BEGIN
  364.                     SortRecords;
  365.                     RecNum:=0; y:=1;
  366.                     WritePage(RecNum);
  367.                   END;
  368.       END;
  369.     UNTIL TheEnd;
  370.     KillWindow(ScrollWin);
  371.     KillWindow(MainWin);
  372.     KillWindow(HelpWin);
  373.     Allowed:=$ff;
  374.   END;
  375.  
  376. BEGIN
  377.   GetARec:=DefGetRec;
  378.   PutARec:=DefPutRec;
  379. END.
  380.